home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 2: Applications / Linux Cubed Series 2 - Applications.iso / editors / emacs / xemacs / xemacs-1.006 / xemacs-1 / lib / xemacs-19.13 / lisp / hyperbole / hmouse-key.el < prev    next >
Encoding:
Text File  |  1995-04-17  |  11.4 KB  |  331 lines
  1. ;;!emacs
  2. ;;
  3. ;; FILE:         hmouse-key.el
  4. ;; SUMMARY:      Load "hmouse-sh.el" or "hmouse-reg.el" for Smart Key bindings.
  5. ;; USAGE:        GNU Emacs Lisp Library
  6. ;; KEYWORDS:     hypermedia, mouse
  7. ;;
  8. ;; AUTHOR:       Bob Weiner
  9. ;; ORG:          Motorola, Inc., PPG
  10. ;;
  11. ;; ORIG-DATE:    30-May-94 at 00:11:57
  12. ;; LAST-MOD:     14-Apr-95 at 16:06:19 by Bob Weiner
  13. ;;
  14. ;; This file is part of Hyperbole.
  15. ;; Available for use and distribution under the same terms as GNU Emacs.
  16. ;;
  17. ;; Copyright (C) 1994-1995, Free Software Foundation, Inc.
  18. ;; Developed with support from Motorola Inc.
  19. ;;
  20. ;; DESCRIPTION:  
  21. ;;
  22. ;;   Supports Epoch, Lucid Emacs, X, Sunview, NEXTSTEP, and Apollo DM
  23. ;;   window systems.
  24. ;;
  25. ;;   'hmouse-setup' globally binds the Action and Assist Mouse Keys.
  26. ;;
  27. ;;   'hmouse-toggle-bindings' may be bound to a key.  It switches between
  28. ;;   Hyperbole mouse bindings and previous mouse key bindings any time
  29. ;;   after 'hmouse-setup' has been called.
  30. ;;
  31. ;; DESCRIP-END.
  32.  
  33. ;;; ************************************************************************
  34. ;;; Other required Elisp libraries
  35. ;;; ************************************************************************
  36.  
  37. ;;; This next expression determines whether shifted mouse keys, "hmouse-sh",
  38. ;;; or unshifted keys, "hmouse-reg" are used as the Action and Assist Keys.
  39. ;;;
  40. (if (and (boundp 'infodock-version) infodock-version)
  41.     ;; Action Key = middle mouse key; Assist Key = right mouse key
  42.     ;; Used under InfoDock.
  43.     (load "hmouse-reg")
  44.   ;; Action Key = shift-middle mouse key; Assist Key = shift-right mouse key
  45.   ;; Standard Hyperbole configuration.
  46.   (load "hmouse-sh"))
  47.  
  48. (require 'hversion)
  49. (require 'hmouse-drv)
  50. (require 'h-skip-bytec "h-skip-bytec.lsp")
  51.  
  52. ;;; ************************************************************************
  53. ;;; Public variables
  54. ;;; ************************************************************************
  55.  
  56. (eval (cdr (assoc hyperb:window-system
  57.           '(
  58.             ;; XEmacs and Emacs 19 pre-load their mouse libraries, so
  59.             ;; we shouldn't have to require them here.
  60.             ;;
  61.             ("xterm"   . (require 'x-mouse))     ; X
  62.             ("epoch"   . (require 'mouse))       ; UofI Epoch
  63.             ("next"    . (load "eterm-fns" t))   ; NeXTstep
  64.             ("sun"     . (require 'sun-fns))     ; SunView
  65.             ("apollo"  . (require 'apollo))      ; Display Manager
  66.             ))))
  67.  
  68. ;;; ************************************************************************
  69. ;;; Public functions
  70. ;;; ************************************************************************
  71.  
  72. (defun hmouse-set-bindings (key-binding-list)
  73.   "Sets mouse keys used as Smart Keys to bindings in KEY-BINDING-LIST.
  74. KEY-BINDING-LIST is the value returned by 'hmouse-get-bindings' prior to
  75. Smart Key setup."
  76.   (cond
  77.     ;;
  78.     ;; GNU Emacs 19 or Lucid Emacs
  79.     ((or (equal hyperb:window-system "emacs19")
  80.      (equal hyperb:window-system "lemacs"))
  81.      (mapcar
  82.        (function
  83.      (lambda (key-and-binding)
  84.       (global-set-key (car key-and-binding) (cdr key-and-binding))))
  85.        key-binding-list))
  86.     ;;
  87.     ;; X
  88.     ((equal hyperb:window-system "xterm")
  89.      (mapcar
  90.        (function
  91.      (lambda (key-and-binding)
  92.        (define-key mouse-map (car key-and-binding) (cdr key-and-binding))))
  93.        key-binding-list))
  94.     ;;
  95.     ;; Epoch
  96.     ((equal hyperb:window-system "epoch")
  97.      (mapcar
  98.        (function
  99.      (lambda (key-and-binding)
  100.       (aset mouse::global-map (car key-and-binding)
  101.         (cdr key-and-binding))))
  102.        key-binding-list))
  103.     ;;
  104.     ;; SunView or NeXT
  105.     ((or (equal hyperb:window-system "next")
  106.      (equal hyperb:window-system "sun"))
  107.      (mapcar
  108.        (function
  109.      (lambda (key-and-binding)
  110.        (global-set-mouse (car key-and-binding) (cdr key-and-binding))))
  111.        key-binding-list))
  112.     ;;
  113.     ;; Apollo Display Manager
  114.     ((equal hyperb:window-system "apollo")
  115.       (if (string< emacs-version "18.58")
  116.       (mapcar
  117.         (function
  118.           (lambda (key-and-binding)
  119.         (global-set-key (car key-and-binding) (cdr key-and-binding))))
  120.         key-binding-list)
  121.     (mapcar
  122.       (function
  123.         (lambda (key-and-binding)
  124.           (define-key 'apollo-prefix (car key-and-binding)
  125.         (cdr key-and-binding)))) 
  126.       key-binding-list))
  127.       )
  128.     ))
  129.  
  130. (defun hmouse-toggle-bindings ()
  131.   "Toggles between Smart Key mouse settings and their prior bindings."
  132.   (interactive)
  133.   (let ((key-binding-list (if hmouse-bindings-flag
  134.                   hmouse-previous-bindings
  135.                 hmouse-bindings))
  136.     (other-list-var (if hmouse-bindings-flag
  137.                 'hmouse-bindings
  138.               'hmouse-previous-bindings)))
  139.     (if key-binding-list
  140.     (progn
  141.       (set other-list-var (hmouse-get-bindings))
  142.       (hmouse-set-bindings key-binding-list)
  143.       (message "%s mouse bindings in use."
  144.            (if (setq hmouse-bindings-flag (not hmouse-bindings-flag))
  145.                "Smart Key" "Personal")))
  146.       (error "(hmouse-toggle-bindings): Null %s." other-list-var))))
  147.  
  148. (defun hmouse-set-point-at (set-point-arg-list)
  149.   "Sets point to cursor position using SET-POINT-ARG-LIST and returns t.
  150. If 'hmouse-set-point-command' is not bound to a function, this does nothing
  151. and returns nil."
  152.   (if (fboundp hmouse-set-point-command)
  153.       (progn
  154.     (if (and (boundp 'drag-zone) drag-zone)
  155.         (progn (delete-zone drag-zone)
  156.            (setq drag-zone nil))
  157.       (and (boundp 'drag-button) drag-button
  158.            (progn (delete-button drag-button)
  159.               (setq drag-button nil))))
  160.     (or (if set-point-arg-list
  161.         (funcall hmouse-set-point-command set-point-arg-list)
  162.           (funcall hmouse-set-point-command))
  163.         t))))
  164.  
  165. ;;; ************************************************************************
  166. ;;; Private functions
  167. ;;; ************************************************************************
  168.  
  169. (if (fboundp 'bind-apollo-mouse-button)
  170.     (progn
  171.       (if (string< emacs-version "18.58")
  172.       (defun apollo-mouse-key-and-binding (mouse-button)
  173.         "Returns binding for an Apollo MOUSE-BUTTON (a string) or nil if none."
  174.         (interactive "sMouse Button: ")
  175.         (let ((numeric-code (cdr (assoc mouse-button *apollo-mouse-buttons*))))
  176.           (if (null numeric-code)
  177.           (error "(hmouse-key): %s is not a valid Apollo mouse key name."
  178.              mouse-button))
  179.           (if (stringp numeric-code)
  180.           (setq numeric-code
  181.             (cdr (assoc numeric-code *apollo-mouse-buttons*))))
  182.           (let ((key-sequence (concat "\M-*" (char-to-string numeric-code))))
  183.         (cons key-sequence (global-key-binding key-sequence)))))
  184.     (defun apollo-mouse-key-and-binding (mouse-button)
  185.       "Returns binding for an Apollo MOUSE-BUTTON (a string) or nil if none."
  186.       (interactive "sMouse Button: ")
  187.       (let ((numeric-code (cdr (assoc mouse-button *apollo-mouse-buttons*))))
  188.         (if (null numeric-code)
  189.         (error "(hmouse-key): %s is not a valid Apollo mouse key name."
  190.                mouse-button))
  191.         (if (stringp numeric-code)
  192.         (setq numeric-code
  193.               (cdr (assoc numeric-code *apollo-mouse-buttons*))))
  194.         (let ((key-sequence (char-to-string numeric-code)))
  195.           (cons key-sequence (lookup-key 'apollo-prefix key-sequence)))))
  196.     )
  197.       (defun apollo-mouse-move-point (&optional no-mark)
  198.     "Used so that pressing the left mouse button, moving the cursor, and
  199. releasing the left mouse button leaves the mark set to the initial position
  200. and the point set to the final position.  Useful for easily marking regions
  201. of text.  If the left mouse button is pressed and released at the same place,
  202. the mark is left at the original position of the character cursor.
  203.  
  204. Returns (x y) frame coordinates of point in columns and lines."
  205.     (interactive)
  206.     (let* ((opoint (point))
  207.            (owindow (selected-window))
  208.            (x (- (read-char) 8))
  209.            (y (- (read-char) 8))
  210.            (edges (window-edges))
  211.            (window nil))
  212.       (while (and (not (eq window (selected-window)))
  213.               (or (<  y (nth 1 edges))
  214.               (>= y (nth 3 edges))
  215.               (<  x (nth 0 edges))
  216.               (>= x (nth 2 edges))))
  217.         (setq window (next-window window))
  218.         (setq edges (window-edges window)))
  219.       (if (and window (not (eq window (selected-window))))
  220.           (progn
  221.         (if (and (not *apollo-mouse-move-point-allow-minibuffer-exit*)
  222.              (eq (selected-window) (minibuffer-window)))
  223.             (error "Cannot use mouse to leave minibuffer!"))
  224.         (if (eq window (minibuffer-window))
  225.             (error "Cannot use mouse to enter minibuffer!"))))
  226.       (if window (select-window window))
  227.       (move-to-window-line (- y (nth 1 edges)))
  228.       (let* ((width-1 (1- (window-width window)))
  229.          (wraps (/ (current-column) width-1))
  230.          (prompt-length (if (eq (selected-window) (minibuffer-window))
  231.                     (minibuffer-prompt-length)
  232.                   0)))
  233.         (move-to-column (+ (- x (nth 0 edges) prompt-length)
  234.                    (* wraps width-1))))
  235.       (if no-mark
  236.           (progn (setq window (selected-window))
  237.              (if (eq owindow window)
  238.              (if (equal opoint (point))
  239.                  (pop-mark))
  240.                (select-window owindow)
  241.                (pop-mark)
  242.                (select-window window)))
  243.         (set-mark-command nil))
  244.       ;; Return (x y) coords of point in column and frame line numbers.
  245.       (list x y)))
  246.       ))
  247.  
  248. (defun action-key-depress (&rest args)
  249.   (interactive)
  250.   (require 'hsite)
  251.   (setq action-key-depress-prev-point (point-marker)
  252.     action-key-depressed-flag t
  253.     action-key-depress-args (hmouse-set-point args)
  254.     action-key-depress-window (selected-window)
  255.     action-key-release-args nil
  256.     action-key-release-window nil
  257.     action-key-release-prev-point nil)
  258.   (if assist-key-depressed-flag
  259.       (or action-key-help-flag
  260.       (setq assist-key-help-flag t))))
  261.  
  262. (defun assist-key-depress (&rest args)
  263.   (interactive)
  264.   (require 'hsite)
  265.   (setq assist-key-depress-prev-point (point-marker)
  266.     assist-key-depressed-flag t
  267.     assist-key-depress-args (hmouse-set-point args)
  268.     assist-key-depress-window (selected-window)
  269.     assist-key-release-args nil
  270.     assist-key-release-window nil
  271.     assist-key-release-prev-point nil)
  272.   (if action-key-depressed-flag
  273.       (or assist-key-help-flag
  274.       (setq action-key-help-flag t)))
  275.   )
  276.  
  277. (defun action-key-depress-emacs19 (event)
  278.   (interactive "e")
  279.   (require 'hsite)
  280.   (action-key-depress event))
  281.  
  282. (defun assist-key-depress-emacs19 (event)
  283.   (interactive "e")
  284.   (require 'hsite)
  285.   (assist-key-depress event))
  286.  
  287. (defun action-mouse-key-emacs19 (event)
  288.   "Set point to the current mouse cursor position and execute 'action-key'.
  289. EVENT will be passed to 'hmouse-function'."
  290.   (interactive "e")
  291.   (action-mouse-key (hmouse-key-release-args-emacs19 event)))
  292.  
  293. (defun assist-mouse-key-emacs19 (event)
  294.   "Set point to the current mouse cursor position and execute 'action-key'.
  295. EVENT will be passed to 'hmouse-function'."
  296.   (interactive "e")
  297.   (assist-mouse-key (hmouse-key-release-args-emacs19 event)))
  298.  
  299. (defun hmouse-key-release-args-emacs19 (event)
  300.   (let ((ev-type-str (and (listp event) (symbol-name (car event)))))
  301.     (if (or (and ev-type-str
  302.          (string-match "\\(double\\|triple\\)-mouse" ev-type-str))
  303.         (not (= (length event) 3)))
  304.     event
  305.       ;; Remove depress coordinates and send only release coordinates.
  306.       (list (car event) (nth 2 event)))))
  307.  
  308. (defun hmouse-move-point-xemacs ()
  309.   (condition-case ()
  310.       (mouse-set-point current-mouse-event)
  311.     ;; Catch "not in a window" errors, e.g. on modeline
  312.     (error nil)))
  313.  
  314. (defun hmouse-move-point-eterm (arg-list)
  315.   (apply 'mouse-move-point arg-list))
  316.  
  317. ;;; ************************************************************************
  318. ;;; Private variables
  319. ;;; ************************************************************************
  320.  
  321. (defvar hmouse-bindings nil
  322.   "List of (key . binding) pairs for Smart Mouse Keys.")
  323.  
  324. (defvar hmouse-bindings-flag nil
  325.   "True if Smart Key mouse bindings are in use, else nil.")
  326.  
  327. (defvar hmouse-previous-bindings nil
  328.   "List of previous (key . binding) pairs for mouse keys used as Smart Keys.")
  329.  
  330. (provide 'hmouse-key)
  331.